home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 2 / Amiga Tools 2.iso / tools / jade / src / lispmach.c < prev    next >
C/C++ Source or Header  |  1995-03-09  |  21KB  |  1,049 lines
  1. /* lispmach.c -- Interpreter for compiled Lisp forms
  2.    Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4.    This file is part of Jade.
  5.  
  6.    Jade is free software; you can redistribute it and/or modify it
  7.    under the terms of the GNU General Public License as published by
  8.    the Free Software Foundation; either version 2, or (at your option)
  9.    any later version.
  10.  
  11.    Jade is distributed in the hope that it will be useful, but
  12.    WITHOUT ANY WARRANTY; without even the implied warranty of
  13.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14.    GNU General Public License for more details.
  15.  
  16.    You should have received a copy of the GNU General Public License
  17.    along with Jade; see the file COPYING.  If not, write to
  18.    the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. #include "jade.h"
  21. #include "jade_protos.h"
  22.  
  23. #ifdef HAVE_ALLOCA
  24. # include <alloca.h>
  25. #endif
  26.  
  27. _PR void lispmach_init(void);
  28.  
  29. #define OP_CALL 0x08
  30. #define OP_PUSH 0x10
  31. #define OP_VREFC 0x18
  32. #define OP_VSETC 0x20
  33. #define OP_LIST 0x28
  34. #define OP_BIND 0x30
  35. #define OP_LAST_WITH_ARGS 0x38
  36.  
  37. #define OP_VREF 0x40
  38. #define OP_VSET 0x41
  39. #define OP_FREF 0x42
  40. #define OP_FSET 0x43
  41. #define OP_INIT_BIND 0x44
  42. #define OP_UNBIND 0x45
  43. #define OP_DUP    0x46
  44. #define OP_SWAP 0x47
  45. #define OP_POP    0x48
  46.  
  47. #define OP_NIL 0x49
  48. #define OP_T 0x4a
  49. #define OP_CONS 0x4b
  50. #define OP_CAR 0x4c
  51. #define OP_CDR 0x4d
  52. #define OP_RPLACA 0x4e
  53. #define OP_RPLACD 0x4f
  54. #define OP_NTH 0x50
  55. #define OP_NTHCDR 0x51
  56. #define OP_ASET 0x52
  57. #define OP_AREF 0x53
  58. #define OP_LENGTH 0x54
  59. #define OP_EVAL 0x55
  60. #define OP_PLUS_2 0x56
  61. #define OP_NEGATE 0x57
  62. #define OP_MINUS_2 0x58
  63. #define OP_PRODUCT_2 0x59
  64. #define OP_DIVIDE_2 0x5a
  65. #define OP_MOD_2 0x5b
  66. #define OP_LOGNOT 0x5c
  67. #define OP_NOT 0x5d
  68. #define OP_LOGIOR_2 0x5e
  69. #define OP_LOGAND_2 0x5f
  70. #define OP_EQUAL 0x60
  71. #define OP_EQ 0x61
  72. #define OP_NUM_EQ 0x62
  73. #define OP_NUM_NOTEQ 0x63
  74. #define OP_GTTHAN 0x64
  75. #define OP_GETHAN 0x65
  76. #define OP_LTTHAN 0x66
  77. #define OP_LETHAN 0x67
  78. #define OP_INC 0x68
  79. #define OP_DEC 0x69
  80. #define OP_LSH 0x6a
  81. #define OP_ZEROP 0x6b
  82. #define OP_NULL 0x6c
  83. #define OP_ATOM 0x6d
  84. #define OP_CONSP 0x6e
  85. #define OP_LISTP 0x6f
  86. #define OP_NUMBERP 0x70
  87. #define OP_STRINGP 0x71
  88. #define OP_VECTORP 0x72
  89. #define OP_CATCH_KLUDGE 0x73
  90. #define OP_THROW 0x74
  91. #define OP_UNWIND_PRO 0x75
  92. #define OP_UN_UNWIND_PRO 0x76
  93. #define OP_FBOUNDP 0x77
  94. #define OP_BOUNDP 0x78
  95. #define OP_SYMBOLP 0x79
  96. #define OP_GET 0x7a
  97. #define OP_PUT 0x7b
  98. #define OP_ERROR_PRO 0x7c
  99. #define OP_SIGNAL 0x7d
  100. #define OP_RETURN 0x7e
  101. #define OP_REVERSE 0x7f        /* new 12/7/94 */
  102. #define OP_NREVERSE 0x80
  103. #define OP_ASSOC 0x81
  104. #define OP_ASSQ 0x82
  105. #define OP_RASSOC 0x83
  106. #define OP_RASSQ 0x84
  107. #define OP_LAST 0x85
  108. #define OP_MAPCAR 0x86
  109. #define OP_MAPC 0x87
  110. #define OP_MEMBER 0x88
  111. #define OP_MEMQ 0x89
  112. #define OP_DELETE 0x8a
  113. #define OP_DELQ 0x8b
  114. #define OP_DELETE_IF 0x8c
  115. #define OP_DELETE_IF_NOT 0x8d
  116. #define OP_COPY_SEQUENCE 0x8e
  117. #define OP_SEQUENCEP 0x8f
  118. #define OP_FUNCTIONP 0x90
  119. #define OP_SPECIAL_FORM_P 0x91
  120. #define OP_SUBRP 0x92
  121. #define OP_EQL 0x93
  122. #define OP_LOGXOR_2 0x94    /* new 23-8-94 */
  123.  
  124. #define OP_SET_CURRENT_BUFFER 0xb0
  125. #define OP_SWAP_BUFFER 0xb1
  126. #define OP_CURRENT_BUFFER 0xb2
  127. #define OP_BUFFERP 0xb3
  128. #define OP_MARKP 0xb4
  129. #define OP_WINDOWP 0xb5
  130. #define OP_SWAP_WINDOW 0xb6
  131.  
  132. #define OP_LAST_BEFORE_JMPS 0xfa
  133. #define OP_JMP 0xfb
  134. #define OP_JN 0xfc
  135. #define OP_JT 0xfd
  136. #define OP_JNP 0xfe
  137. #define OP_JTP 0xff
  138.  
  139. #define TOP        (*stackp)
  140. #define RET_POP        (*stackp--)
  141. #define POP        (stackp--)
  142. #define POPN(n)        (stackp -= n)
  143. #define PUSH(v)        (*(++stackp) = (v))
  144. #define STK_USE        (stackp - (stackbase - 1))
  145.  
  146. #define ARG_SHIFT    8
  147. #define OP_ARG_MASK  0x07
  148. #define OP_OP_MASK   0xf8
  149. #define OP_ARG_1BYTE 6
  150. #define OP_ARG_2BYTE 7
  151.  
  152. /* These macros pop as many args as required then call the specified
  153.    function properly. */
  154.  
  155. #define CALL_1(cmd)                \
  156.     if((TOP = cmd (TOP)))            \
  157.     break;                    \
  158.     goto error
  159.     
  160. #define CALL_2(cmd)                \
  161.     tmp = RET_POP;                \
  162.     if((TOP = cmd (TOP, tmp)))            \
  163.     break;                    \
  164.     goto error
  165.  
  166. #define CALL_3(cmd)                \
  167.     tmp = RET_POP;                \
  168.     tmp2 = RET_POP;                \
  169.     if((TOP = cmd (TOP, tmp2, tmp)))        \
  170.     break;                    \
  171.     goto error
  172.  
  173. _PR VALUE cmd_jade_byte_code(VALUE code, VALUE consts, VALUE stkreq);
  174. DEFUN("jade-byte-code", cmd_jade_byte_code, subr_jade_byte_code, (VALUE code, VALUE consts, VALUE stkreq), V_Subr3, DOC_jade_byte_code) /*
  175. ::doc:jade_byte_code::
  176. jade-byte-code CODE-STRING CONST-VEC MAX-STACK
  177.  
  178. Evaluates the string of byte codes CODE-STRING, the constants that it
  179. references are contained in the vector CONST-VEC. MAX-STACK is a number
  180. defining how much stack space is required to evaluate the code.
  181.  
  182. Do *not* attempt to call this function manually, the lisp file `compiler.jl'
  183. contains a simple compiler which translates files of lisp forms into files
  184. of byte code. See the functions `compile-file', `compile-directory' and
  185. `compile-lisp-lib' for more details.
  186. ::end:: */
  187. {
  188.     VALUE *stackbase;
  189.     register VALUE *stackp;
  190.     /* This holds a list of sets of bindings, it can also hold the form of
  191.        an unwind-protect that always gets eval'd (when the car is t).  */
  192.     VALUE bindstack = sym_nil;
  193.     register u_char *pc;
  194.     u_char c;
  195.     GCVAL gcv_code, gcv_consts, gcv_bindstack;
  196.     /* The `gcv_N' field is only filled in with the stack-size when there's
  197.        a chance of gc.    */
  198.     GCVALN gcv_stackbase;
  199.  
  200.     DECLARE1(code, STRINGP);
  201.     DECLARE2(consts, VECTORP);
  202.     DECLARE3(stkreq, NUMBERP);
  203.  
  204. #ifdef HAVE_ALLOCA
  205.     stackbase = alloca(sizeof(VALUE) * VNUM(stkreq));
  206. #else
  207.     if(!(stackbase = str_alloc(sizeof(VALUE) * VNUM(stkreq))))
  208.     return(NULL);
  209. #endif
  210.  
  211.     stackp = stackbase - 1;
  212.     PUSHGC(gcv_code, code);
  213.     PUSHGC(gcv_consts, consts);
  214.     PUSHGC(gcv_bindstack, bindstack);
  215.     PUSHGCN(gcv_stackbase, stackbase, 0);
  216.  
  217.     pc = VSTR(code);
  218.     while((c = *pc++) != 0)
  219.     {
  220.     if(c < OP_LAST_WITH_ARGS)
  221.     {
  222.         register short arg;
  223.         switch(c & OP_ARG_MASK)
  224.         {
  225.         case OP_ARG_1BYTE:
  226.         arg = *pc++;
  227.         break;
  228.         case OP_ARG_2BYTE:
  229.         arg = (pc[0] << ARG_SHIFT) | pc[1];
  230.         pc += 2;
  231.         break;
  232.         default:
  233.         arg = c & OP_ARG_MASK;
  234.         }
  235.         switch(c & OP_OP_MASK)
  236.         {
  237.         register VALUE tmp;
  238.         VALUE tmp2;
  239.  
  240.         case OP_CALL:
  241. #ifdef MINSTACK
  242.         if(STK_SIZE <= MINSTACK)
  243.         {
  244.             STK_WARN("lisp-code");
  245.             TOP = cmd_signal(sym_stack_error, sym_nil);
  246.             goto quit;
  247.         }
  248. #endif
  249.         /* args are still available above the top of the stack,
  250.            this just makes things a bit easier.     */
  251.         POPN(arg);
  252.         tmp = TOP;
  253.         if(SYMBOLP(tmp))
  254.         {
  255.             if(VSYM(tmp)->sym_Flags & SF_DEBUG)
  256.             single_step_flag = TRUE;
  257.             if(!(tmp = cmd_symbol_function(tmp, sym_nil)))
  258.             goto error;
  259.         }
  260.         gcv_stackbase.gcv_N = STK_USE;
  261.         switch(VTYPE(tmp))
  262.         {
  263.         case V_Subr0:
  264.             TOP = VSUBR0FUN(tmp)();
  265.             break;
  266.         case V_Subr1:
  267.             TOP = VSUBR1FUN(tmp)(arg >= 1 ? stackp[1] : sym_nil);
  268.             break;
  269.         case V_Subr2:
  270.             switch(arg)
  271.             {
  272.             case 0:
  273.             TOP = VSUBR2FUN(tmp)(sym_nil, sym_nil);
  274.             break;
  275.             case 1:
  276.             TOP = VSUBR2FUN(tmp)(stackp[1], sym_nil);
  277.             break;
  278.             default:
  279.             TOP = VSUBR2FUN(tmp)(stackp[1], stackp[2]);
  280.             break;
  281.             }
  282.             break;
  283.         case V_Subr3:
  284.             switch(arg)
  285.             {
  286.             case 0:
  287.             TOP = VSUBR3FUN(tmp)(sym_nil, sym_nil, sym_nil);
  288.             break;
  289.             case 1:
  290.             TOP = VSUBR3FUN(tmp)(stackp[1], sym_nil, sym_nil);
  291.             break;
  292.             case 2:
  293.             TOP = VSUBR3FUN(tmp)(stackp[1], stackp[2], sym_nil);
  294.             break;
  295.             default:
  296.             TOP = VSUBR3FUN(tmp)(stackp[1], stackp[2], stackp[3]);
  297.             break;
  298.             }
  299.             break;
  300.         case V_Subr4:
  301.             switch(arg)
  302.             {
  303.             case 0:
  304.             TOP = VSUBR4FUN(tmp)(sym_nil, sym_nil,
  305.                          sym_nil, sym_nil);
  306.             break;
  307.             case 1:
  308.             TOP = VSUBR4FUN(tmp)(stackp[1], sym_nil,
  309.                          sym_nil, sym_nil);
  310.             break;
  311.             case 2:
  312.             TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
  313.                          sym_nil, sym_nil);
  314.             break;
  315.             case 3:
  316.             TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
  317.                          stackp[3], sym_nil);
  318.             break;
  319.             default:
  320.             TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
  321.                          stackp[3], stackp[4]);
  322.             break;
  323.             }
  324.             break;
  325.         case V_Subr5:
  326.             switch(arg)
  327.             {
  328.             case 0:
  329.             TOP = VSUBR5FUN(tmp)(sym_nil, sym_nil, sym_nil,
  330.                          sym_nil, sym_nil);
  331.             break;
  332.             case 1:
  333.             TOP = VSUBR5FUN(tmp)(stackp[1], sym_nil, sym_nil,
  334.                          sym_nil, sym_nil);
  335.             break;
  336.             case 2:
  337.             TOP = VSUBR5FUN(tmp)(stackp[1], stackp[2], sym_nil,
  338.                          sym_nil, sym_nil);
  339.             break;
  340.             case 3:
  341.             TOP = VSUBR5FUN(tmp)(stackp[1], stackp[2], stackp[3],
  342.                          sym_nil, sym_nil);
  343.             break;
  344.             case 4:
  345.             TOP = VSUBR5FUN(tmp)(stackp[1], stackp[2], stackp[3],
  346.                          stackp[4], sym_nil);
  347.             default:
  348.             TOP = VSUBR5FUN(tmp)(stackp[1], stackp[2], stackp[3],
  349.                          stackp[4], stackp[5]);
  350.             break;
  351.             }
  352.             break;
  353.         case V_SubrN:
  354.             tmp2 = sym_nil;
  355.             POPN(-arg); /* reclaim my args */
  356.             while(arg--)
  357.             tmp2 = cmd_cons(RET_POP, tmp2);
  358.             TOP = VSUBRNFUN(tmp)(tmp2);
  359.             break;
  360.         case V_Cons:
  361.             tmp2 = sym_nil;
  362.             POPN(-arg);
  363.             while(arg--)
  364.             tmp2 = cmd_cons(RET_POP, tmp2);
  365.             if(VCAR(tmp) == sym_lambda)
  366.             {
  367.             struct LispCall lc;
  368.             lc.lc_Next = lisp_call_stack;
  369.             lc.lc_Fun = TOP;
  370.             lc.lc_Args = tmp2;
  371.             lc.lc_ArgsEvalledP = sym_t;
  372.             lisp_call_stack = &lc;
  373.             if(!(TOP = eval_lambda(tmp, tmp2, FALSE))
  374.                && throw_value
  375.                && (VCAR(throw_value) == sym_defun))
  376.             {
  377.                 TOP = VCDR(throw_value);
  378.                 throw_value = NULL;
  379.             }
  380.             lisp_call_stack = lc.lc_Next;
  381.             }
  382.             else if(VCAR(tmp) == sym_autoload)
  383.             /* I can't be bothered to go to all the hassle
  384.                of doing this here, it's going to be slow
  385.                anyway so just pass it to funcall.  */
  386.             TOP = funcall(TOP, tmp2);
  387.             else
  388.             {
  389.             cmd_signal(sym_invalid_function, LIST_1(TOP));
  390.             goto error;
  391.             }
  392.             break;
  393.         default:
  394.             cmd_signal(sym_invalid_function, LIST_1(TOP));
  395.             goto error;
  396.         }
  397.         if(!TOP)
  398.             goto error;
  399.         break;
  400.  
  401.         case OP_PUSH:
  402.         PUSH(VVECT(consts)->vc_Array[arg]);
  403.         break;
  404.  
  405.         case OP_VREFC:
  406.         if(PUSH(cmd_symbol_value(VVECT(consts)->vc_Array[arg],
  407.                      sym_nil)))
  408.         {
  409.             break;
  410.         }
  411.         goto error;
  412.  
  413.         case OP_VSETC:
  414.         if(cmd_set(VVECT(consts)->vc_Array[arg], RET_POP))
  415.             break;
  416.         goto error;
  417.  
  418.         case OP_LIST:
  419.         tmp = sym_nil;
  420.         while(arg--)
  421.             tmp = cmd_cons(RET_POP, tmp);
  422.         PUSH(tmp);
  423.         break;
  424.  
  425.         case OP_BIND:
  426.         tmp = VVECT(consts)->vc_Array[arg];
  427.         if(SYMBOLP(tmp))
  428.         {
  429.             VCAR(bindstack) = bind_symbol(VCAR(bindstack), tmp,
  430.                           RET_POP);
  431.             break;
  432.         }
  433.         goto error;
  434.         }
  435.     }
  436.     else
  437.     {
  438.         switch(c)
  439.         {
  440.         register VALUE tmp;
  441.         VALUE tmp2;
  442.         int i;
  443.  
  444.         case OP_POP:
  445.         POP;
  446.         break;
  447.  
  448.         case OP_VREF:
  449.         if((TOP = cmd_symbol_value(TOP, sym_nil)))
  450.             break;
  451.         goto error;
  452.  
  453.         case OP_VSET:
  454.         tmp = RET_POP;
  455.         if(cmd_set(tmp, RET_POP))
  456.             break;
  457.         goto error;
  458.  
  459.         case OP_FREF:
  460.         if((TOP = cmd_symbol_function(TOP, sym_nil)))
  461.             break;
  462.         goto error;
  463.  
  464.         case OP_FSET:
  465.         tmp = RET_POP;
  466.         if(cmd_fset(tmp, RET_POP))
  467.             break;
  468.         goto error;
  469.  
  470.         case OP_INIT_BIND:
  471.         bindstack = cmd_cons(sym_nil, bindstack);
  472.         break;
  473.  
  474.         case OP_UNBIND:
  475.         unbind_symbols(VCAR(bindstack));
  476.         bindstack = VCDR(bindstack);
  477.         break;
  478.  
  479.         case OP_DUP:
  480.         tmp = TOP;
  481.         PUSH(tmp);
  482.         break;
  483.  
  484.         case OP_SWAP:
  485.         tmp = TOP;
  486.         TOP = stackp[-1];
  487.         stackp[-1] = tmp;
  488.         break;
  489.  
  490.         case OP_NIL:
  491.         PUSH(sym_nil);
  492.         break;
  493.  
  494.         case OP_T:
  495.         PUSH(sym_t);
  496.         break;
  497.  
  498.         case OP_CONS:
  499.         CALL_2(cmd_cons);
  500.  
  501.         case OP_CAR:
  502.         tmp = TOP;
  503.         if(CONSP(tmp))
  504.             TOP = VCAR(tmp);
  505.         else
  506.             TOP = sym_nil;
  507.         break;
  508.  
  509.         case OP_CDR:
  510.         tmp = TOP;
  511.         if(CONSP(tmp))
  512.             TOP = VCDR(tmp);
  513.         else
  514.             TOP = sym_nil;
  515.         break;
  516.  
  517.         case OP_RPLACA:
  518.         CALL_2(cmd_rplaca);
  519.  
  520.         case OP_RPLACD:
  521.         CALL_2(cmd_rplacd);
  522.  
  523.         case OP_NTH:
  524.         CALL_2(cmd_nth);
  525.  
  526.         case OP_NTHCDR:
  527.         CALL_2(cmd_nthcdr);
  528.  
  529.         case OP_ASET:
  530.         CALL_3(cmd_aset);
  531.  
  532.         case OP_AREF:
  533.         CALL_2(cmd_aref);
  534.  
  535.         case OP_LENGTH:
  536.         CALL_1(cmd_length);
  537.  
  538.         case OP_EVAL:
  539.         gcv_stackbase.gcv_N = STK_USE;
  540.         CALL_1(cmd_eval);
  541.  
  542.         case OP_PLUS_2:
  543.         tmp = RET_POP;
  544.         if(NUMBERP(tmp) && NUMBERP(TOP))
  545.         {
  546.             TOP = make_number(VNUM(TOP) + VNUM(tmp));
  547.             break;
  548.         }
  549.         goto error;
  550.  
  551.         case OP_NEGATE:
  552.         if(NUMBERP(TOP))
  553.         {
  554.             TOP = make_number(-VNUM(TOP));
  555.             break;
  556.         }
  557.         goto error;
  558.  
  559.         case OP_MINUS_2:
  560.         tmp = RET_POP;
  561.         if(NUMBERP(tmp) && NUMBERP(TOP))
  562.         {
  563.             TOP = make_number(VNUM(TOP) - VNUM(tmp));
  564.             break;
  565.         }
  566.         goto error;
  567.  
  568.         case OP_PRODUCT_2:
  569.         tmp = RET_POP;
  570.         if(NUMBERP(tmp) && NUMBERP(TOP))
  571.         {
  572.             TOP = make_number(VNUM(TOP) * VNUM(tmp));
  573.             break;
  574.         }
  575.         goto error;
  576.  
  577.         case OP_DIVIDE_2:
  578.         tmp = RET_POP;
  579.         if(NUMBERP(tmp) && NUMBERP(TOP))
  580.         {
  581.             TOP = make_number(VNUM(TOP) / VNUM(tmp));
  582.             break;
  583.         }
  584.         goto error;
  585.  
  586.         case OP_MOD_2:
  587.         tmp = RET_POP;
  588.         if(NUMBERP(tmp) && NUMBERP(TOP))
  589.         {
  590.             TOP = make_number(VNUM(TOP) % VNUM(tmp));
  591.             break;
  592.         }
  593.         goto error;
  594.  
  595.         case OP_LOGNOT:
  596.         if(NUMBERP(TOP))
  597.         {
  598.             TOP = make_number(~VNUM(TOP));
  599.             break;
  600.         }
  601.         goto error;
  602.  
  603.         case OP_NOT:
  604.         if(TOP == sym_nil)
  605.             TOP = sym_t;
  606.         else
  607.             TOP = sym_nil;
  608.         break;
  609.  
  610.         case OP_LOGIOR_2:
  611.         tmp = RET_POP;
  612.         if(NUMBERP(tmp) && NUMBERP(TOP))
  613.         {
  614.             TOP = make_number(VNUM(TOP) | VNUM(tmp));
  615.             break;
  616.         }
  617.         goto error;
  618.  
  619.         case OP_LOGXOR_2:
  620.         tmp = RET_POP;
  621.         if(NUMBERP(tmp) && NUMBERP(TOP))
  622.         {
  623.             TOP = make_number(VNUM(TOP) ^ VNUM(tmp));
  624.             break;
  625.         }
  626.         goto error;
  627.  
  628.         case OP_LOGAND_2:
  629.         tmp = RET_POP;
  630.         if(NUMBERP(tmp) && NUMBERP(TOP))
  631.         {
  632.             TOP = make_number(VNUM(TOP) & VNUM(tmp));
  633.             break;
  634.         }
  635.         goto error;
  636.  
  637.         case OP_EQUAL:
  638.         tmp = RET_POP;
  639.         if(!(VALUE_CMP(TOP, tmp)))
  640.             TOP = sym_t;
  641.         else
  642.             TOP = sym_nil;
  643.         break;
  644.  
  645.         case OP_EQ:
  646.         tmp = RET_POP;
  647.         if(TOP == tmp)
  648.             TOP = sym_t;
  649.         else
  650.             TOP = sym_nil;
  651.         break;
  652.  
  653.         case OP_NUM_EQ:
  654.         CALL_2(cmd_num_eq);
  655.  
  656.         case OP_NUM_NOTEQ:
  657.         CALL_2(cmd_num_noteq);
  658.  
  659.         case OP_GTTHAN:
  660.         tmp = RET_POP;
  661.         if(VALUE_CMP(TOP, tmp) > 0)
  662.             TOP = sym_t;
  663.         else
  664.             TOP = sym_nil;
  665.         break;
  666.  
  667.         case OP_GETHAN:
  668.         tmp = RET_POP;
  669.         if(VALUE_CMP(TOP, tmp) >= 0)
  670.             TOP = sym_t;
  671.         else
  672.             TOP = sym_nil;
  673.         break;
  674.  
  675.         case OP_LTTHAN:
  676.         tmp = RET_POP;
  677.         if(VALUE_CMP(TOP, tmp) < 0)
  678.             TOP = sym_t;
  679.         else
  680.             TOP = sym_nil;
  681.         break;
  682.  
  683.         case OP_LETHAN:
  684.         tmp = RET_POP;
  685.         if(VALUE_CMP(TOP, tmp) <= 0)
  686.             TOP = sym_t;
  687.         else
  688.             TOP = sym_nil;
  689.         break;
  690.  
  691.         case OP_INC:
  692.         if(NUMBERP(TOP))
  693.         {
  694.             TOP = make_number(VNUM(TOP) + 1);
  695.             break;
  696.         }
  697.         goto error;
  698.  
  699.         case OP_DEC:
  700.         if(NUMBERP(TOP))
  701.         {
  702.             TOP = make_number(VNUM(TOP) - 1);
  703.             break;
  704.         }
  705.         goto error;
  706.  
  707.         case OP_LSH:
  708.         CALL_2(cmd_lsh);
  709.  
  710.         case OP_ZEROP:
  711.         if(NUMBERP(TOP) && (VNUM(TOP) == 0))
  712.             TOP = sym_t;
  713.         else
  714.             TOP = sym_nil;
  715.         break;
  716.  
  717.         case OP_NULL:
  718.         if(NILP(TOP))
  719.             TOP = sym_t;
  720.         else
  721.             TOP = sym_nil;
  722.         break;
  723.  
  724.         case OP_ATOM:
  725.         if(!CONSP(TOP))
  726.             TOP = sym_t;
  727.         else
  728.             TOP = sym_nil;
  729.         break;
  730.  
  731.         case OP_CONSP:
  732.         if(CONSP(TOP))
  733.             TOP = sym_t;
  734.         else
  735.             TOP = sym_nil;
  736.         break;
  737.  
  738.         case OP_LISTP:
  739.         if(CONSP(TOP) || NILP(TOP))
  740.             TOP = sym_t;
  741.         else
  742.             TOP = sym_nil;
  743.         break;
  744.  
  745.         case OP_NUMBERP:
  746.         if(NUMBERP(TOP))
  747.             TOP = sym_t;
  748.         else
  749.             TOP = sym_nil;
  750.         break;
  751.  
  752.         case OP_STRINGP:
  753.         if(STRINGP(TOP))
  754.             TOP = sym_t;
  755.         else
  756.             TOP = sym_nil;
  757.         break;
  758.  
  759.         case OP_VECTORP:
  760.         if(VECTORP(TOP))
  761.             TOP = sym_t;
  762.         else
  763.             TOP = sym_nil;
  764.         break;
  765.  
  766.         case OP_CATCH_KLUDGE:
  767.         /* This is very crude.    */
  768.         tmp = RET_POP;
  769.         tmp = cmd_cons(tmp, cmd_cons(TOP, sym_nil));
  770.         gcv_stackbase.gcv_N = STK_USE;
  771.         if((TOP = cmd_catch(tmp)))
  772.             break;
  773.         goto error;
  774.  
  775.         case OP_THROW:
  776.         tmp = RET_POP;
  777.         if(!throw_value)
  778.             throw_value = cmd_cons(TOP, tmp);
  779.         /* This isn't really an error :-)  */
  780.         goto error;
  781.  
  782.         case OP_UNWIND_PRO:
  783.         tmp = RET_POP;
  784.         bindstack = cmd_cons(cmd_cons(sym_t, tmp), bindstack);
  785.         break;
  786.  
  787.         case OP_UN_UNWIND_PRO:
  788.         gcv_stackbase.gcv_N = STK_USE;
  789.         /* there will only be one form (a lisp-code) */
  790.         cmd_eval(VCDR(VCAR(bindstack)));
  791.         bindstack = VCDR(bindstack);
  792.         break;
  793.  
  794.         case OP_FBOUNDP:
  795.         CALL_1(cmd_fboundp);
  796.  
  797.         case OP_BOUNDP:
  798.         CALL_1(cmd_boundp);
  799.  
  800.         case OP_SYMBOLP:
  801.         if(SYMBOLP(TOP))
  802.             TOP = sym_t;
  803.         else
  804.             TOP = sym_nil;
  805.         break;
  806.  
  807.         case OP_GET:
  808.         CALL_2(cmd_get);
  809.  
  810.         case OP_PUT:
  811.         CALL_3(cmd_put);
  812.  
  813.         case OP_ERROR_PRO:
  814.         /* bit of a kludge, this just calls the special-form, it
  815.            takes an extra argument on top of the stack - the number
  816.            of arguments that it has been given.     */
  817.         i = VNUM(RET_POP);
  818.         tmp = sym_nil;
  819.         while(i--)
  820.             tmp = cmd_cons(RET_POP, tmp);
  821.         gcv_stackbase.gcv_N = STK_USE;
  822.         tmp = cmd_error_protect(tmp);
  823.         if(tmp)
  824.         {
  825.             PUSH(tmp);
  826.             break;
  827.         }
  828.         goto error;
  829.  
  830.         case OP_SIGNAL:
  831.         CALL_2(cmd_signal);
  832.  
  833.         case OP_RETURN:
  834.         if(!throw_value)
  835.             throw_value = cmd_cons(sym_defun, TOP);
  836.         goto error;
  837.  
  838.         case OP_REVERSE:
  839.         CALL_1(cmd_reverse);
  840.  
  841.         case OP_NREVERSE:
  842.         CALL_1(cmd_nreverse);
  843.  
  844.         case OP_ASSOC:
  845.         CALL_2(cmd_assoc);
  846.  
  847.         case OP_ASSQ:
  848.         CALL_2(cmd_assq);
  849.  
  850.         case OP_RASSOC:
  851.         CALL_2(cmd_rassoc);
  852.  
  853.         case OP_RASSQ:
  854.         CALL_2(cmd_rassq);
  855.  
  856.         case OP_LAST:
  857.         CALL_1(cmd_last);
  858.  
  859.         case OP_MAPCAR:
  860.         CALL_2(cmd_mapcar);
  861.  
  862.         case OP_MAPC:
  863.         CALL_2(cmd_mapc);
  864.  
  865.         case OP_MEMBER:
  866.         CALL_2(cmd_member);
  867.  
  868.         case OP_MEMQ:
  869.         CALL_2(cmd_memq);
  870.  
  871.         case OP_DELETE:
  872.         CALL_2(cmd_delete);
  873.  
  874.         case OP_DELQ:
  875.         CALL_2(cmd_delq);
  876.  
  877.         case OP_DELETE_IF:
  878.         CALL_2(cmd_delete_if);
  879.  
  880.         case OP_DELETE_IF_NOT:
  881.         CALL_2(cmd_delete_if_not);
  882.  
  883.         case OP_COPY_SEQUENCE:
  884.         CALL_1(cmd_copy_sequence);
  885.  
  886.         case OP_SEQUENCEP:
  887.         CALL_1(cmd_sequencep);
  888.  
  889.         case OP_FUNCTIONP:
  890.         CALL_1(cmd_functionp);
  891.  
  892.         case OP_SPECIAL_FORM_P:
  893.         CALL_1(cmd_special_form_p);
  894.  
  895.         case OP_SUBRP:
  896.         CALL_1(cmd_subrp);
  897.  
  898.         case OP_EQL:
  899.         tmp = RET_POP;
  900.         if(NUMBERP(tmp) && NUMBERP(TOP))
  901.             TOP = (VNUM(TOP) == VNUM(tmp) ? sym_t : sym_nil);
  902.         else
  903.             TOP = (TOP == tmp ? sym_t : sym_nil);
  904.         break;
  905.  
  906.         case OP_SET_CURRENT_BUFFER:
  907.         CALL_2(cmd_set_current_buffer);
  908.  
  909.         case OP_SWAP_BUFFER:
  910.         if(!BUFFERP(TOP))
  911.             goto error;
  912.         TOP = VAL(swap_buffers_tmp(curr_vw, VTX(TOP)));
  913.         break;
  914.  
  915.         case OP_CURRENT_BUFFER:
  916.         CALL_1(cmd_current_buffer);
  917.  
  918.         case OP_BUFFERP:
  919.         if(BUFFERP(TOP))
  920.             TOP = sym_t;
  921.         else
  922.             TOP = sym_nil;
  923.         break;
  924.  
  925.         case OP_MARKP:
  926.         if(MARKP(TOP))
  927.             TOP = sym_t;
  928.         else
  929.             TOP = sym_nil;
  930.         break;
  931.  
  932.         case OP_WINDOWP:
  933.         if(WINDOWP(TOP))
  934.             TOP = sym_t;
  935.         else
  936.             TOP = sym_nil;
  937.         break;
  938.  
  939.         case OP_SWAP_WINDOW:
  940.         tmp = TOP;
  941.         if(!WINDOWP(tmp))
  942.             goto error;
  943.         TOP = VAL(curr_vw);
  944.         curr_vw = VWIN(tmp);
  945.         break;
  946.  
  947.         case OP_JN:
  948.         if(NILP(RET_POP))
  949.             goto do_jmp;
  950.         pc += 2;
  951.         break;
  952.  
  953.         case OP_JT:
  954.         if(!NILP(RET_POP))
  955.             goto do_jmp;
  956.         pc += 2;
  957.         break;
  958.  
  959.         case OP_JNP:
  960.         if(NILP(TOP))
  961.             goto do_jmp;
  962.         POP;
  963.         pc += 2;
  964.         break;
  965.  
  966.         case OP_JTP:
  967.         if(NILP(TOP))
  968.         {
  969.             POP;
  970.             pc += 2;
  971.             break;
  972.         }
  973.         /* FALL THROUGH */
  974.  
  975.         case OP_JMP:
  976.         do_jmp:
  977.         pc = VSTR(code) + ((pc[0] << ARG_SHIFT) | pc[1]);
  978.  
  979.         /* Test if an error occurred (or an interrupt) */
  980.         TEST_INT;
  981.         if(INT_P)
  982.             goto error;
  983.         /* Test for gc time */
  984.         if((data_after_gc >= gc_threshold) && !gc_inhibit)
  985.         {
  986.             gcv_stackbase.gcv_N = STK_USE;
  987.             cmd_garbage_collect(sym_t);
  988.         }
  989.         break;
  990.  
  991.         default:
  992.         cmd_signal(sym_error,
  993.                LIST_1(MKSTR("Unknown lisp opcode")));
  994.         error:
  995.         while(CONSP(bindstack))
  996.         {
  997.             if(VCAR(VCAR(bindstack)) == sym_t)
  998.             {
  999.             /* an unwind-pro */
  1000.             GCVAL gcv_throwval;
  1001.             VALUE throwval = throw_value;
  1002.             throw_value = NULL;
  1003.             PUSHGC(gcv_throwval, throwval);
  1004.             cmd_eval(VCDR(VCAR(bindstack)));
  1005.             POPGC;
  1006.             throw_value = throwval;
  1007.             }
  1008.             else
  1009.             unbind_symbols(VCAR(bindstack));
  1010.             bindstack = VCDR(bindstack);
  1011.         }
  1012.         TOP = NULL;
  1013.         goto quit;
  1014.         }
  1015.     }
  1016. #ifdef PARANOID
  1017.     if(stackp < (stackbase - 1))
  1018.     {
  1019.         fprintf(stderr, "jade: stack underflow in lisp-code: aborting...\n");
  1020.         abort();
  1021.     }
  1022.     if(stackp > (stackbase + VNUM(stkreq)))
  1023.     {
  1024.         fprintf(stderr, "jade: stack overflow in lisp-code: aborting...\n");
  1025.         abort();
  1026.     }
  1027. #endif
  1028.     }
  1029. #ifdef PARANOID
  1030.     if(stackp != stackbase)
  1031.     fprintf(stderr, "jade: (stackp != stackbase) at end of lisp-code\n");
  1032. #endif
  1033.     
  1034.  quit:
  1035.     /* only use this var to save declaring another */
  1036.     bindstack = TOP;
  1037. #ifndef HAVE_ALLOCA
  1038.     str_free(stackbase);
  1039. #endif
  1040.     POPGCN; POPGC; POPGC; POPGC;
  1041.     return(bindstack);
  1042. }
  1043.  
  1044. void
  1045. lispmach_init(void)
  1046. {
  1047.     ADD_SUBR(subr_jade_byte_code);
  1048. }
  1049.